home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
HPAVC
/
HPAVC CD-ROM.iso
/
PRUS101.ZIP
/
FSTR.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1994-12-19
|
18KB
|
600 lines
UNIT FSTR; { FIDO unit for string handling and manipulation }
(***************************************************************************
RELEASE 1.06 - as contained in the file PRUS101.LZH
by Peter Holschbach, 2:2450/660.3, GERMANY
--------------------------------------------
organized for Fido's PASCAL related echoes
--------------------------------------------
05/14/1994 to 06/26/1994 by Orazio Czerwenka, 2:2450/540.55, GERMANY
06/26/1994 to --/--/---- by Peter Holschbach, 2:2450/660.3, GERMANY
As far as third party copyrights are not violated this
source code is hereby placed to the public domain. Use
it whatever way you want, but use AT YOUR OWN RISK.
In case you should modify the source rather send your
modifications to the unit's current organizer (see above for
NM address) than to spread it on your own. This will help to
keep the unit updated and grant a certain standard to all
other users as well.
The unit is currently still under work. So it might greatly
benefit of your participation.
Those who contributed to the following piece of source,
listed in alphabethical order:
================================================================
Orazio Czerwenka, Peter Holschbach, Peter Schuette ...
================================================================
YOUR NAME WILL APPEAR HERE IF YOU CONTRIBUTE USEFUL SOURCE.
Credits in your own programs are as welcome as unnecessary.
***************************************************************************)
{$I FDEFINE.DEF}
interface
type
FieldOfStrings = Array [0..20] of String;
Var PartCount : Word;
function PosCount (findstr, strName : String): Byte;
function RedPosCount (findstr, strName: String): Byte;
function PosX (Xpos: byte; findstr, strName: String): Byte;
function LastPos (findstr, strName: String): Byte;
function CharListPos (findlst,strName: String) : Word;
function CharListNoPos (findlst,strName: String): Word;
function MirrorString (strName: String): String;
function UpperString (strName: String): String;
function LowerString (strName: String): String;
function RemoveLeft (remo,strName: String): String;
function RemoveRight (remo,strName: String): String;
function RemoveLeftRight (remo,strName: String): String;
function RemoveAll (remo,strName: String): String;
function StripSpaceTAB (strName: String): String;
function StripLeadingSpaceTAB (strName: String): String;
procedure PartString (PartBy: String; Var StringField : FieldOfStrings);
procedure PartStringBySpaceTAB (Var StringField : FieldOfStrings);
procedure PartStringByComma (Var StringField : FieldOfStrings);
function Resemble (a, b: String): Byte;
function WildMatch (Pattern,Source: String) : Boolean;
function EnsureBackslash (strName: String) : String;
function EnsureNoBackslash (strName: String) : String;
Function EscToString (strName:String) : String;
Function StringToEsc (strName:String) : String;
implementation
Type
CharArray255 = Array [1..255] of Char;
{----------------------------------------------------------------------------}
function CharListPos(findlst,strName: String) : Word;
{ Original author: Peter Holschbach,
modifications Orazio Czerwenka }
Var L : Word;
Position : Word;
TempPosition : Word;
Begin
If strName = '' then Begin
CharListPos:= 0;
Exit;
End;
Position := 256;
For L := 1 to Length (findlst) do Begin
TempPosition := Pos (findlst [L],strName);
If (TempPosition > 0) and (TempPosition < Position)
then Position := TempPosition;
End;
If Position = 256 then CharListPos:= 0
Else CharListPos:= Position;
End;
{----------------------------------------------------------------------------}
function CharListNoPos (findlst,strName: String): Word;
{ Original author: Peter Holschbach,
modifications Orazio Czerwenka }
Var L : Word;
Position : Word;
InFindLst : Boolean;
Begin
If strName = '' then Begin
CharListNoPos:= 0;
Exit;
End;
Position := 1;
Repeat
InFindLst := False;
For L:= 1 to Length (findlst) do
If (strName [Position] = findlst [L]) then InFindLst := True;
Inc (Position);
Until (Position > Length (strName)) OR Not InFindLst;
If Not InFindLst
then CharListNoPos:= Position - 1
else CharListNoPos:= Length(strName)+1;
End;
{----------------------------------------------------------------------------}
function PosCount (findstr,strName:String):byte;
{ Original author: Orazio Czerwenka }
VAR
i,
b : byte;
tmpstr: string;
BEGIN
b:= 0;
tmpstr:= strName;
FOR i:= 1 TO Length(tmpstr) DO
IF copy(tmpstr,i,length(findstr))= findstr THEN BEGIN
inc(b);
delete(tmpstr,i,length(findstr)-1);
END;
IF b > 0
THEN PosCount:= b
ELSE PosCount:= 0;
END;
{----------------------------------------------------------------------------}
function RedPosCount (findstr,strName:String):byte;
{ Original author: Orazio Czerwenka }
VAR
i,
b : byte;
BEGIN
b:= 0;
FOR i:= 1 TO Length(strName)-(length(findstr)-1) DO
IF copy(strname,i,length(findstr))= findstr THEN inc(b);
IF b > 0
THEN RedPosCount:= b
ELSE RedPosCount:= 0;
END;
{----------------------------------------------------------------------------}
function LastPos (findstr,strName:String):Byte;
{ Original author: Orazio Czerwenka }
VAR
b : Byte;
BEGIN
b:= Pos(MirrorString(findstr),MirrorString(strName));
IF b > 0
THEN LastPos:= (length(strName)+1)-b-(length(findstr)-1)
ELSE LastPos:= b;
END;
{----------------------------------------------------------------------------}
function PosX (Xpos: byte; findstr, strName: String): Byte;
{ Original author: Orazio Czerwenka }
Var
X,
b : Byte;
begin
X:= 0;
for b:= 1 to Xpos do begin
X:= X + pos(findstr,strName);
delete (strName,1,pos(findstr,strName)+ord(findstr[0])-1);
end;
PosX:= X;
end;
{----------------------------------------------------------------------------}
function MirrorString (strName:string):string;
{ Original author: Orazio Czerwenka }
VAR
n : byte;
NewStr : string;
BEGIN
MirrorString:= strName;
NewStr:= ''; { Necessary to initialize variable }
if strName = '' then exit;
FOR n:= 0 TO length(strName)-1 DO
NewStr:= NewStr + strName[length(strName)-n];
MirrorString:= NewStr;
END;
{----------------------------------------------------------------------------}
function UpperString(strName:String):String;
{ Original author: Orazio Czerwenka }
VAR
n : byte;
BEGIN
FOR n:=1 TO Length(strName) DO
CASE ord(strName[n]) OF
129 : strName[n]:= chr(154); { ue - Ue }
130 : strName[n]:= chr(144); { é - É }
132 : strName[n]:= chr(142); { ae - Ae }
134 : strName[n]:= chr(143); { å - Å }
135 : strName[n]:= chr(128); { ç - Ç }
145 : strName[n]:= chr(146); { æ - Æ }
148 : strName[n]:= chr(153); { oe - Oe }
164 : strName[n]:= chr(165); { ñ - Ñ }
ELSE strName[n]:= UpCase(strName[n]);
END;
UpperString:=StrName;
END;
{----------------------------------------------------------------------------}
function LowerString(strName:String):String;
{ Original author: Orazio Czerwenka }
VAR
n : byte;
BEGIN
FOR n:=1 TO Length(strName) DO
CASE ord(strName[n]) OF
154 : strName[n]:= chr(129); { Ue - ue }
144 : strName[n]:= chr(130); { É - é }
142 : strName[n]:= chr(132); { Ae - ae }
143 : strName[n]:= chr(134); { Å - å }
128 : strName[n]:= chr(135); { Ç - ç }
146 : strName[n]:= chr(145); { Æ - æ }
153 : strName[n]:= chr(148); { Oe - oe }
165 : strName[n]:= chr(164); { Ñ - ñ }
65..90 : strName[n]:= chr(ord(strName[n])+32);
END;
LowerString:=StrName;
END;
{----------------------------------------------------------------------------}
function RemoveLeft (remo,strName: String): String;
{ Original author: Orazio Czerwenka }
var
b : byte;
dummy: char;
remov: CharArray255;
function DummyInRemov: Boolean;
var
b : byte;
begin
DummyInRemov:= true;
for b:= 1 to ord(remo[0]) do if dummy = remov[b] then exit;
DummyInRemov:= false;
end;
begin
RemoveLeft:= strName;
if remo = '' then exit;
FillChar(remov,255,#0);
for b:= 1 to ord(remo[0]) do remov[b]:= remo[b];
Repeat
for b:= 1 to ord(remo[0]) do begin
dummy:= remo[b];
Repeat
if strName[1] = dummy then delete(strName,1,1);
Until (strName[1] <> dummy) or (strName = '');
end;
if strName <> ''
then dummy:= strName[1]
else dummy:= #0;
if not DummyInRemov then remov[1]:= #0;
Until (remov[1] = #0) or (strName = '');
RemoveLeft:= strName;
end;
{----------------------------------------------------------------------------}
function RemoveRight (remo,strName: String): String;
{ Original author: Orazio Czerwenka }
begin
RemoveRight:=
Mirrorstring(RemoveLeft(remo,MirrorString(strName)));
end;
{----------------------------------------------------------------------------}
function RemoveLeftRight (remo,strName: String): String;
{ Original author: Orazio Czerwenka }
var
dummy : string;
begin
dummy:= RemoveLeft(remo,strName);
RemoveLeftRight:=
Mirrorstring(RemoveLeft(remo,MirrorString(dummy)));
end;
{----------------------------------------------------------------------------}
function RemoveAll (remo,strName: String): String;
{ Original author: Orazio Czerwenka }
var
i,
b: byte;
begin
i:= 1;
Repeat
b:= 1;
Repeat
if strName[b] = remo[i] then delete(strName,b,1)
else inc(b);
Until b > ord(strName[0]);
inc(i);
Until i > ord(remo[0]);
RemoveAll:= strName;
end;
{----------------------------------------------------------------------------}
function StripSpaceTAB (strName: String): String;
{ Original author: Peter Holschbach,
modifications Orazio Czerwenka }
begin
StripSpaceTAB:= RemoveAll(' '+#9,strName);
End;
{----------------------------------------------------------------------------}
function StripLeadingSpaceTAB (strName: String): String;
{ Original author: Peter Holschbach,
modifications Orazio Czerwenka }
begin
StripLeadingSpaceTAB:= RemoveLeft(' '+#9,strName);
end;
{----------------------------------------------------------------------------}
procedure PartString (PartBy: String; Var StringField : FieldOfStrings);
{ Original author: Peter Holschbach,
modifications Orazio Czerwenka
190994 modifications Peter Holschbach }
Var
strName : String;
Position : Word;
QuotationFound : Boolean;
Begin
QuotationFound := False;
PartCount := 0;
strName := StringField [0]; (* the String to split *)
FillChar(StringField,SizeOf(StringField),0); (* fill the whole Strings with '' *)
StringField[0]:= strName;
If StringField [0] = '' then Exit;
Repeat
Position := CharListNoPos(PartBy+'"',strName);
QuotationFound := (Position > 1) AND (strName [Position-1] = '"');
Delete (strName,1,Position-1); (* delete all leading chars *)
If QuotationFound Then
Position := CharListPos('"',strName)
Else
Position := CharListPos(PartBy,strName);
If (Position = 0) then Begin
If strName <> '' then Begin
Inc (PartCount);
StringField [PartCount] := strName;
strName := '';
End
End
Else Begin
Inc (PartCount);
StringField [PartCount] := Copy (strName,1,Position - 1);
Delete (strName,1,Position);
End;
Until strName = '';
End;
{----------------------------------------------------------------------------}
procedure PartStringBySpaceTAB (Var StringField : FieldOfStrings);
{ Original author: Peter Holschbach,
modifications Orazio Czerwenka }
Begin
PartString (' '#9,StringField);
End;
{----------------------------------------------------------------------------}
procedure PartStringByComma (Var StringField : FieldOfStrings);
{ Original author: Peter Holschbach,
modifications Orazio Czerwenka }
Begin
PartString (',',StringField);
End;
{----------------------------------------------------------------------------}
{ returns TRUE if the string in Source matches the string in Pattern
The pattern may contain any number of the wild characters '*' and '?'
'?' matches any single character
'*' matches any sequence of charcters (including a zero length sequence)
EG '*m?t*i*' will match 'Automatic' }
function WildMatch(Pattern,Source: String) : boolean;
{ Original author: Peter Schuette,
modifications Orazio Czerwenka }
function Rmatch(VAR s: String; i: Integer;
VAR p: String; j: Integer) : boolean;
{ s = to be tested , i = position in s }
{ p = pattern to match ,j = position in p }
var
matched: Boolean;
k : Integer;
BEGIN
IF p[0]=CHR(0) THEN Begin RMatch := True; Exit; End;
REPEAT
IF ((i > Length(s)) OR (s[i] = CHR(0))) AND
((j > Length(p)) OR (p[j] = CHR(0))) THEN Begin
RMatch := True; Exit; End
ELSE IF ((j > Length(p)) OR (p[j] = CHR(0))) THEN Begin
RMatch := False; Exit; End
ELSE IF (p[j] = '*') THEN Begin
k :=i;
IF ((j = Length(p)) OR (p[j+1] = CHR(0))) THEN Begin
RMatch := True; Exit; End
ELSE Begin
REPEAT
matched := Rmatch(s,k,p,j+1);
INC(k);
UNTIL matched OR (k > Length(s)) OR (s[k] = CHR(0));
RMatch := matched; Exit;
END
End
ELSE IF (p[j] <> '?') AND (UpCase(p[j]) <> UpCase(s[i])) THEN Begin
RMatch := False; Exit; End
ELSE Begin
INC(i);
INC(j);
END;
Until 1=0;
END;
BEGIN
WildMatch := Rmatch(Source,1,Pattern,1);
END;
{----------------------------------------------------------------------------}
{ The resulting byte reports the degree the strings equal each other.
The higher the value, the more different the strings are. (0 reports
identical entries) }
function Resemble(a, b: String): Byte;
{ Original author: Peter Schuette,
modifications Orazio Czerwenka }
Var i, sresult, sres1 : Byte;
xchnge, bcopy : String;
deleted : Boolean;
Begin {Resemble}
sresult := 255;
If Length(a) < Length(b) Then Begin
xchnge := a;
a := b;
b := xchnge;
End;
If Length(a) < Length(b) Then
For i := 1 to Length(a) Do Begin
bcopy := b;
Insert(#0, bcopy, i);
sres1 := Resemble(a, bcopy);
If sres1 < sresult Then sresult := sres1;
End
Else Begin
sres1 := 0;
i := 1;
While i <= Length(a) Do
If a[i] = b[i] Then Begin
Delete(a, i, 1);
Delete(b, i, 1);
End
Else inc(i);
i := 2;
deleted := False;
While i <= Length(a) Do
If a[i] = b[i-1] Then Begin
Delete(a, i, 1);
Delete(b, i-1, 1);
deleted := True;
End
Else inc(i);
If deleted Then inc(sres1);
i := 2;
deleted := False;
While i <= Length(b) Do
If a[i-1] = b[i] Then Begin
Delete(a, i-1, 1);
Delete(b, i, 1);
deleted := True;
End
Else inc(i);
If deleted Then inc(sres1);
sres1 := sres1 + Length(a);
if sres1 < sresult then sresult := sres1
End;
resemble := sresult;
End; {Resemble}
{----------------------------------------------------------------------------}
function EnsureBackslash (strName:String) : String;
{ Original author: Peter Holschbach,
modifications Orazio Czerwenka }
begin
if strName[ord(strName[0])] <> '\' then EnsureBackslash:= strName + '\'
else EnsureBackslash:= strName;
end;
{----------------------------------------------------------------------------}
function EnsureNoBackslash (strName:String) : String;
{ Original author: Orazio Czerwenka }
begin
EnsureNoBackslash:= RemoveRight(' \',strName);
end;
{----------------------------------------------------------------------------}
Function EscToString (strName:String) : String;
{ Original author: Peter Holschbach }
Var s : String;
L : Byte;
Begin
s := '';
for L := 1 to Length (StrName) do Begin
If StrName [L] = '^' then Begin
s := s + '^^';
End
Else If Ord (strName [L]) < 64 then Begin
s := s + '^' + Chr (Ord (strName [L]) + 64);
End
Else Begin
s := s + strName [L]
End;
End;
EscToString := s;
End;
{----------------------------------------------------------------------------}
Function StringToEsc (strName:String) : String;
{ Original author: Peter Holschbach }
Var s : String;
L : Byte;
Begin
L := 1;
s := '';
While L < Length (strName) do Begin
If StrName [L] = '^' Then Begin
If (StrName [L+1] <> '^') AND (ORD (StrName [L+1]) >= 64) Then Begin
S := s + Chr (ORD (StrName [L+1]) - 64);
INC (L,2);
End
Else Begin
S:= S + StrName [L] + StrName [L+1];
Inc (L,2);
End;
End
Else Begin
s := s + StrName [L];
Inc (L);
End;
End;
StringToEsc := S;
End;
{----------------------------------------------------------------------------}
END.